home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / clisp_c.zoo / defmacro.lsp < prev    next >
Lisp/Scheme  |  1993-06-05  |  29KB  |  616 lines
  1. ;;;; File DEFMACRO.LSP
  2. ;;; Macro DEFMACRO und einige Hilfsfunktionen für komplizierte Macros.
  3. ;;; 1. 9. 1988
  4. ;;; Adaptiert an DEFTYPE am 10.6.1989
  5.  
  6. (in-package "SYSTEM")
  7.  
  8. ;; Import aus CONTROL.Q:
  9.  
  10. #| (SYSTEM::PARSE-BODY body &optional docstring-allowed env)
  11.    expandiert die ersten Formen in der Formenliste body (im Function-
  12.    Environment env), entdeckt dabei auftretende Deklarationen (und falls
  13.    docstring-allowed=T, auch einen Docstring) und liefert drei Werte:
  14.    1. body-rest, die restlichen Formen,
  15.    2. declspec-list, eine Liste der aufgetretenen Decl-Specs,
  16.    3. docstring, ein aufgetretener Docstring oder NIL.
  17. |#
  18. #| (SYSTEM::KEYWORD-TEST arglist kwlist)
  19.    testet, ob arglist (eine paarige Keyword/Value-Liste) nur Keywords
  20.    enthält, die auch in der Liste kwlist vorkommen, oder aber ein
  21.    Keyword/Value-Paar :ALLOW-OTHER-KEYS mit Value /= NIL enthält.
  22.    Wenn nein, wird ein Error ausgelöst.
  23. |#
  24. #| (keyword-test arglist kwlist) überprüft, ob in arglist (eine Liste
  25. von Keyword/Value-Paaren) nur Keywords vorkommen, die in kwlist vorkommen,
  26. oder ein Keyword/Value-Paar mit Keyword = :ALLOW-OTHER-KEYS und Value /= NIL
  27. vorkommt. Sollte dies nicht der Fall sein, wird eine Errormeldung ausgegeben.
  28.  
  29. (defun keyword-test (arglist kwlist)
  30.   (let ((unallowed-arglistr nil)
  31.         (allow-other-keys-flag nil))
  32.     (do ((arglistr arglist (cddr arglistr)))
  33.         ((null arglistr))
  34.       (if (eq (first arglistr) ':ALLOW-OTHER-KEYS)
  35.           (if (second arglistr) (setq allow-other-keys-flag t))
  36.           (do ((kw (first arglistr))
  37.                (kwlistr kwlist (cdr kwlistr)))
  38.               ((or (null kwlistr) (eq kw (first kwlistr)))
  39.                (if (and (null kwlistr) (null unallowed-arglistr))
  40.                    (setq unallowed-arglistr arglistr)
  41.     ) )   )   ))
  42.     (unless allow-other-keys-flag
  43.       (if unallowed-arglistr
  44.         (cerror #+DEUTSCH "Beide werden übergangen."
  45.                 #+ENGLISH "It will be ignored."
  46.                 #+FRANCAIS "Ignorer les deux."
  47.                 #+DEUTSCH "Unzulässiges Keyword ~S mit Wert ~S"
  48.                 #+ENGLISH "Invalid keyword-value-pair: ~S ~S"
  49.                 #+FRANCAIS "Mot-clé illégal ~S, valeur ~S"
  50.                 (first unallowed-arglistr) (second unallowed-arglistr)
  51.     ) ) )
  52. ) )
  53. ; Definition in Assembler siehe CONTROL.Q
  54. |#
  55.  
  56. (defun macro-call-error (macro-form)
  57.   (error #+DEUTSCH "Der Macro ~S kann nicht mit ~S Argumenten aufgerufen werden: ~S"
  58.          #+ENGLISH "The macro ~S may not be called with ~S arguments"
  59.          #+FRANCAIS "Le macro ~S ne peut pas être appelé avec ~S arguments : ~S"
  60.          (car macro-form) (1- (length macro-form)) macro-form
  61. ) )
  62.  
  63. (proclaim '(special
  64.         %restp ; gibt an, ob &REST/&BODY/&KEY angegeben wurde,
  65.                ; also ob die Argumentanzahl unbeschränkt ist.
  66.  
  67.         %min-args ; gibt die Anzahl der notwendigen Argumente an
  68.  
  69.         %arg-count ; gibt die Anzahl der Einzelargumente an
  70.                    ; (notwendige und optionale Argumente, zusammengezählt)
  71.  
  72.         %let-list ; umgedrehte Liste der Bindungen, die mit LET* zu machen sind
  73.  
  74.         %keyword-tests ; Liste der KEYWORD-TEST - Aufrufe, die einzubinden sind
  75.  
  76.         %default-form ; Default-Form für optionale und Keyword-Argumente,
  77.                    ; bei denen keine Default-Form angegeben ist.
  78.                    ; =NIL normalerweise, = (QUOTE *) für DEFTYPE.
  79. )          )
  80. #|
  81. (ANALYZE1 lambdalist accessexp name wholevar)
  82. analysiert eine Macro-Lambdaliste (ohne &ENVIRONMENT). accessexp ist der
  83. Ausdruck, der die Argumente liefert, die mit dieser Lambdaliste zu matchen
  84. sind.
  85.  
  86. (ANALYZE-REST lambdalistr restexp name)
  87. analysiert den Teil einer Macro-Lambdaliste, der nach &REST/&BODY kommt.
  88. restexp ist der Ausdruck, der die Argumente liefert, die mit diesem
  89. Listenrest zu matchen sind.
  90.  
  91. (ANALYZE-KEY lambdalistr restvar name)
  92. analysiert den Teil einer Macro-Lambdaliste, der nach &KEY kommt.
  93. restvar ist das Symbol, das die restlichen Argumente enthalten wird.
  94.  
  95. (ANALYZE-AUX lambdalistr name) 
  96. analysiert den Teil einer Macro-Lambdaliste, der nach &AUX kommt.
  97.  
  98. (REMOVE-ENV-ARG lambdalist name)
  99. entfernt das Paar &ENVIRONMENT/Symbol aus einer Macro-Lambdaliste,
  100. liefert zwei Werte: die verkürzte Lambdaliste und das als Environment zu
  101. verwendende Symbol (oder die Lambdaliste selbst und NIL, falls &ENVIRONMENT
  102. nicht auftritt).
  103.  
  104. (MAKE-LENGTH-TEST symbol)
  105. kreiert aus %restp, %min-args, %arg-count eine Testform, die bei Auswertung
  106. anzeigt, ob der Inhalt der Variablen symbol als Aufruferform zum Macro
  107. dienen kann.
  108.  
  109. (MAKE-MACRO-EXPANSION macrodef)
  110. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  111. 1. den Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)),
  112. 2. name, ein Symbol,
  113. 3. lambdalist,
  114. 4. docstring (oder NIL, wenn keiner da).
  115. |#
  116.  
  117. (%proclaim-constant 'macro-missing-value (list 'macro-missing-value))
  118. ; einmaliges Objekt
  119.  
  120. (%putd 'analyze-aux
  121.   (function analyze-aux
  122.     (lambda (lambdalistr name)
  123.       (do ((listr lambdalistr (cdr listr)))
  124.           ((atom listr)
  125.            (if listr
  126.              (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  127.                      #+ENGLISH "The rest of the lambda list will be ignored."
  128.                      #+FRANCAIS "Ignorer ce qui suit."
  129.                      #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &AUX."
  130.                      #+ENGLISH "The lambda list of macro ~S contains a dot after &AUX."
  131.                      #+FRANCAIS "La liste lambda du macro ~S contient un point après &AUX."
  132.                      name
  133.           )) )
  134.         (cond ((symbolp (car listr)) (setq %let-list (cons `(,(car listr) nil) %let-list)))
  135.               ((atom (car listr))
  136.                (error #+DEUTSCH "Im Macro ~S ist als &AUX-Variable nicht verwendbar: ~S"
  137.                       #+ENGLISH "in macro ~S: ~S may not be used as &AUX variable."
  138.                       #+FRANCAIS "Dans le macro ~S, l'utilisation de ~S n'est pas possible comme variable &AUX."
  139.                       name (car listr)
  140.               ))
  141.               (t (setq %let-list
  142.                    (cons `(,(caar listr) ,(cadar listr)) %let-list)
  143.   ) ) ) )     )  )
  144. )
  145.  
  146. (%putd 'analyze-key
  147.   (function analyze-key
  148.     (lambda (lambdalistr restvar name &aux (otherkeysforbidden t) (kwlist nil))
  149.       (do ((listr lambdalistr (cdr listr))
  150.            (next)
  151.            (kw)
  152.            (svar)
  153.            (g))
  154.           ((atom listr)
  155.            (if listr
  156.              (cerror #+DEUTSCH "Der Teil danach wird ignoriert."
  157.                      #+ENGLISH "The rest of the lambda list will be ignored."
  158.                      #+FRANCAIS "Ignorer ce qui suit."
  159.                      #+DEUTSCH "Die Lambdaliste des Macros ~S enthält einen Punkt nach &KEY."
  160.                      #+ENGLISH "The lambda list of macro ~S contains a dot after &KEY."
  161.                      #+FRANCAIS "La liste lambda du macro ~S contient un point après &KEY."
  162.                      name
  163.           )) )
  164.         (setq next (car listr))
  165.         (cond ((eq next '&ALLOW-OTHER-KEYS) (setq otherkeysforbidden nil))
  166.               ((eq next '&AUX) (return-from nil (analyze-aux (cdr listr) name)))
  167.               ((or (eq next '&ENVIRONMENT) (eq next '&WHOLE) (eq next '&OPTIONAL)
  168.                    (eq next '&REST) (eq next '&BODY) (eq next '&KEY)
  169.                )
  170.                (cerror #+DEUTSCH "Es wird ignoriert."
  171.                        #+ENGLISH "It will be ignored."
  172.                        #+FRANCAIS "Ignorer ce qui suit."
  173.                        #+DEUTSCH "Die Lambdaliste des Macros ~S enthält ein ~S an falscher Stelle."
  174.                        #+ENGLISH "The lambda list of macro ~S contains a badly placed ~S."
  175.                        #+FRANCAIS "La liste lambda du macro ~S contient un ~S mal placé."
  176.                        name next
  177.               ))
  178.               (t
  179.                 (if %default-form
  180.                   (cond ((symbolp next) (setq next (list next %default-form)))
  181.                         ((and (consp next) (eql (length next) 1))
  182.                          (setq n